#!/usr/bin/perl -c

package PIPL::Class::Base;
use 5.006;
our $VERSION = '0.01';

=head1 NAME

PIPL::Class::Base - Base class for PIPL

=head1 SYNOPSIS

  package My::Person;
  use base 'PIPL::Class::Base';

  use constant FIELDS => {
      name     => { is => 'rw', default => 'Anonymous' },
      age      => { is => 'rw' },
      activity => { is => 'ro' },
  };

  1;

  package My::Employee;
  use base 'My::Employee';

  use constant FIELDS => {
      %{ My::Person->FIELDS },
      salary   => { is => 'rw' },
      vacation => { is => 'ro' },
  };

  sub print_salary {
      my $self = shift;
      printf '%s earn $%s\n",
          defined $self->{name} ? $self->{name} : $self->{defaults}->{name},
          $self->{salary};
  }

  1;

  package main;

  my $employee = new My::Employee name=>'J.Smith', age=>34, job=>'webmaster';
  $employee->print_salary;
  printf "%s is %s\n", $employee->{name}, $employee->{properties}->{job}
      if defined $employee->{properties}->{job};

=head1 DESCRIPTION

This is a base class for other classes which handles the class's fields.  The
class's fields are implemented as a common blessed hash reference.  Each class
which uses L<PIPL::Class::Base> have to declare the B<FIELDS> constant.  The
B<FIELDS> constant describes the class's fields.

The class has special fields: I<properties> and I<defaults>.  The
I<properties> field contains the values which can not be writted to the normal
field, because it is read-only field or it is does not defined as field at
least.  The I<defaults> field contains the list of default values as
S<I<field> =E<gt> I<default>> pairs.

The L<PIPL::Class::Base> also provides the standard B<new()> constructor.

=cut


use strict;


use base 'Class::Cloneable';


use Scalar::Util 'weaken';


# List of class fields (name => {is=>ro|rw, default=>value})
use constant FIELDS => {
    defaults       => { is => 'ro' },
    properties     => { is => 'ro' },
};


# Use Scalar::Util or pure Perl implementation
our $Pure_Perl;


# Cache for class' FIELDS
my %Class_Fields;


# Cache for class' defaults
my %Class_Defaults;


# Constructor
sub new {
    my $class = shift;
    $class = ref $class if ref $class;

    my $fields;
    my $defaults;

    # Use cached value if available
    if (not defined $Class_Fields{$class}) {
        $fields = $Class_Fields{$class} = $class->FIELDS;
        $defaults = $Class_Defaults{$class} = {
            map { $_ => $fields->{$_}->{default} }
                grep { defined $fields->{$_}->{default} }
                    (keys %$fields)
        };
    }
    else {
        $fields = $Class_Fields{$class};
        $defaults = $Class_Defaults{$class};
    }

    my $self = {};
    bless $self => $class;

    # If the attribute is rw, initialize its value. Otherwise: properties.
    my %args = @_;
    $self->{properties} = {};
    foreach my $key (keys %args) {
        if (defined $fields->{$key}->{is} and $fields->{$key}->{is} eq 'rw') {
            $self->{$key} = $args{$key};
        }
        else {
            $self->{properties}->{$key} = $args{$key};
        }
        if ($fields->{$key}->{weak_ref} and ref $self->{$key}) {
            weaken $self->{$key};
        }
    }

    # Defaults for this object
    $self->{defaults} = { %$defaults };
    foreach my $key (keys %$defaults) {
        if (not defined $self->{$key}) {
            $self->{$key} = $self->clone($defaults->{$key});
        }
    }

    return $self;
}


# Clone this object or argument
sub clone {
    my $self = shift;
    my $ref = shift;

    return $self->new if not defined $ref and not ref $self;

    return Class::Cloneable::Util::clone(defined $ref ? $ref : $self);
}


1;


=head1 BASE CLASSES

=over 2

=item *

L<Class::Cloneable>

=back

=head1 CONSTANTS

=over

=item FIELDS

Declaration of class fields as reference to hash.

The fields are listed as I<name> => {I<properties>}, where I<properties> is a
list of field properties:

=over

=item is

Can be 'rw' for read-write fields or 'ro' for read-only fields.

=item default

Optional property with the default value.  Should be used if the field value
is not defined.  The default value is set by B<new> constructor.

=item weak_ref

Optional property which means that field holds weakened reference. See
L<Scalar::Util> for explanation.  The reference is weakened by B<new>
constructor.

=back

The read-write fields can be set with B<new> constructor directly.  The
read-only fields will be stored in B<properties> field.

The constant have to be defined in derivered class if it brings additional
fields.

The default value is deeply copied to the field if the field's value is
undefined on initialization.

An example:

  package Class::Class::Base;
  use base 'PIPL::Class::Base';

  # Define new class fields
  use constant FIELDS => {
    readonly  => { is=>'ro', default=>'value' },  # new ro field
    readwrite => { is=>'rw' },                    # new rw field
  };

  package Class::My;
  use base 'Class::Class::Base';

  # Define new class fields
  use constant FIELDS => {
    %{Class::Class::Base->FIELDS},       # base's fields have to be first
    anotherreadonly  => { is=>'ro' },             # new ro field
  };

  package main;
  my $obj = Class::My readwrite=>2, anotherreadonly=>3;
  print $obj->{readwrite};                       # = 2
  print $obj->{defaults}->{readonly};            # = 'value'
  print $obj->{properties}->{readonly};          # = 'value'
  print $obj->{properties}->{anotherreadonly};   # = 3

=back

=head1 FIELDS

Class fields are implemented as values of blessed hash.

=over

=item properties (ro)

Contains the additional properies of the exception.  If the parameter for
B<new()> constructor is read-only field or does not exist on fields list,
this parameter is included to the B<properties> field.

=item defaults (ro)

Meta-field contains the list of default values.

=back

=head1 CONSTRUCTORS

=over

=item new([%I<args>])

Creates the object. If the key of the argument is read-write field, this
field will be filled. Otherwise, the B<properties> field will be used.

If the field is undefined and the default value is defined, its default value
is deeply copied to the field.

The constructor reads the list of class fields from FIELDS constant function
and stores it in the internal cache for performance reason.  The defaults
values for the class are also stored in internal cache.

  $obj = new PIPL::Class::Base;

If called as a method of existing object, creates new object of the same class as
an existing object.

  $obj1 = new PIPL::Class::Base;
  $obj1->{properties}->{f} = 1;
  $obj2 = new $obj1;  # obj2 is the new PIPL::Class::Base object
  print $obj2->{properties}->{f};   # undefined: this is new object

=item clone

Deeply copies the data.

If called as a method of existing object, created new object and deeply
copies existing object's fields into new empty object as a hash reference.

  $obj1 = new PIPL::Class::Base;
  $obj1->{properties}->{f} = 1;
  $obj2 = clone $obj1;  # obj2 is the new PIPL::Class::Base object
  print $obj2->{properties}->{f};     # 1
  $obj2->{properties}->{f} = 2;
  print $obj1->{properties}->{f};     # 1: the obj1 is not touched

If called as a static method, creates the new object.

  $obj2 = clone PIPL::Class::Base;  # the new empty object

=item clone($I<ref>)

If called with parameter, just copies the data of the parameter to the new
reference.

  $ref1 = [ 1, 2, 3 ];
  $ref2 = PIPL::Class::Base->clone($ref1);
  $ref2->[0] = 4;
  print "$ref1->[0] != $ref2->[0]\n";  # 1 != 4: the new reference is created

=back

=head1 SEE ALSO

L<Class::Cloneable>.

=head1 TESTS

The module was tested with L<Devel::Cover> and L<Devel::Dprof>.

=head1 BUGS

If you find the bug, please report it.

=head1 AUTHORS

Piotr Roszatycki E<lt>dexter@debian.orgE<gt>

=head1 LICENSE

Copyright 2007 by Piotr Roszatycki E<lt>dexter@debian.orgE<gt>.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>
